unit GeneticAlgs;

{$MINENUMSIZE 2}
{$POINTERMATH ON}

// "Hamming Cliff" - always forget how its called :).

interface

uses
  Windows, Classes, SysUtils, Math, Generics.Collections, Generics.Defaults;

type
  // TEvolution ================================================================

  // Selection:    Random, RouletteWheel, Rank, Tournament, Crowding
  // Replacement:  Complete, Elitism, Rank, Tournament, RTS, WAMS

  TSelectionKind   = (skUniform, skRouletteWheel, skRank, skTour);
  TReplacementKind = (rkClassic, rkElitism, rkSteadyState, rkSteadyElitism,
                      rkTour);

  TEvolution<T> = class abstract
  public type
    PItem = ^TItem;
    TItem = record
      Value:   T;
      Fitness: Double;
    end;

    TSelection = class abstract
    private
      FEvolution: TEvolution<T>;
    public
      constructor Create(AEvolution: TEvolution<T>);
      function    Kind: TSelectionKind; virtual; abstract;
      procedure   NextGeneration; virtual;
      procedure   Select(out AMom, ADad: PItem); virtual; abstract;
    end;

    TUniformSeln = class(TSelection)
    public
      function  Kind: TSelectionKind; override;
      procedure Select(out AMom, ADad: PItem); override;
    end;

    TRouletteWheelSeln = class(TSelection)
    private
      FItems: TArray<TItem>;
      FNormd: TArray<Double>;
      FRW:    TArray<PItem>;
    public
      function  Kind: TSelectionKind; override;
      procedure NextGeneration; override;
      procedure Select(out AMom, ADad: PItem); override;
    end;

    TRankSeln = class(TSelection)
    private
      FItems:   TArray<TItem>;
      FRanked:  TArray<PItem>;
      procedure SortItems(L, R: Integer);
    public
      function  Kind: TSelectionKind; override;
      procedure NextGeneration; override;
      procedure Select(out AMom, ADad: PItem); override;
    end;

    TTourSeln = class(TSelection)
    public
      function  Kind: TSelectionKind; override;
      procedure Select(out AMom, ADad: PItem); override;
    end;

    TReplacement = class abstract
    private
      FEvolution: TEvolution<T>;
    public
      constructor Create(AEvolution: TEvolution<T>);
      function    Kind: TReplacementKind; virtual; abstract;
      procedure   NextGeneration; virtual;
      procedure   Step; virtual; abstract;
    end;

    TClassicRepl = class(TReplacement)
    private
      FElitism: Boolean;
      FNewGen:  TArray<TItem>;
    public
      constructor Create(AEvolution: TEvolution<T>; AElitism: Boolean);
      function    Kind: TReplacementKind; override;
      procedure   Step; override;
    end;

    TSteadyStateRepl = class(TReplacement)
    private
      FElitism: Boolean;
    public
      constructor Create(AEvolution: TEvolution<T>; AElitism: Boolean);
      function    Kind: TReplacementKind; override;
      procedure   Step; override;
    end;

    TTourRepl = class(TReplacement)
    public
      function  Kind: TReplacementKind; override;
      procedure Step; override;
    end;
  private
    FInited:               Boolean;
    FPopulationSize:       Integer;
    FSelection:            TSelection;
    FIncestPrevention:     Integer;
    FReplacement:          TReplacement;
    FReInitPropbability:   Double;
    FItems:                TArray<TItem>;
    FBest:                 PItem;
    FCrossoverProbability: Double;
    FMutationProbability:  Double;
    FGenerations:          Integer;
    FEvaluations:          Integer;

    procedure InitRandomPopulation;
    procedure DetemineBest;
    function  GetItems(AIndex: Integer): TItem;
    function  GetBest: T;
    function  GetSelectionKind: TSelectionKind;
    procedure SetSelectionKind(const Value: TSelectionKind);
    function  GetReplacementKind: TReplacementKind;
    procedure SetReplacementKind(const Value: TReplacementKind);
  protected
    function  CreateRandom: T; virtual; abstract;
    function  Evaluate(const AValue: T): Double; virtual; abstract;
    function  Distance(const AMom, ADad: T): Double; virtual; abstract;
    function  Crossover(const AMom, ADad: T): T; virtual; abstract;
    procedure Mutate(var AValue: T); virtual; abstract;
    procedure CreateChild(out AChild: TItem);
  public
    constructor Create(APopulationSize: Integer);
    destructor Destroy; override;

    function  Step: Integer;
    procedure Cataclysm;
    procedure ReevalAll;
    property  Generations: Integer read FGenerations;
    property  Evaluations: Integer read FEvaluations;
    property  PopulationSize: Integer read FPopulationSize;
    property  Items[AIndex: Integer]: TItem read GetItems; default;
    property  Best: T read GetBest;
    property  SelectionKind: TSelectionKind read GetSelectionKind write SetSelectionKind;
    property  IncestPrevention: Integer read FIncestPrevention write FIncestPrevention;
    property  ReplacementKind: TReplacementKind read GetReplacementKind write SetReplacementKind;
    property  CrossoverProbability: Double read FCrossoverProbability write FCrossoverProbability;
    property  MutationProbability: Double read FMutationProbability write FMutationProbability;
    property  ReInitPropbability: Double read FReInitPropbability write FReInitPropbability;
  end;

  // TBinaryEvolution ==========================================================

  TPostInitProc<T> = reference to procedure(var AValue: T);
  TMutate<T>       = reference to procedure(var AValue: T; var AHandled: Boolean);

  TMutationKind  = (mkUniform, mkSingleBit);
  TCrossoverKind = (ckUniform, ckOnePoint);

  TBinaryEvolution<T: record> = class(TEvolution<T>) // T should be a POD type.
  private
    FFunc:          TFunc<T, Double>;
    FMutationKind:  TMutationKind;
    FCrossoverKind: TCrossoverKind;
    FOnPostInit:    TPostInitProc<T>;
    FOnMutate:      TMutate<T>;

    function  IsEqual(const A, B: T): Boolean;
    function  UniformCrossover(const M, D: T): T;
    function  OnePointCrossover(const M, D: T): T;
    procedure SingleBitMutation(var V: T);
    procedure UniformMutation(var V: T);
  protected
    function  CreateRandom: T; override;
    function  Distance(const AMom, ADad: T): Double; override;
    function  Crossover(const AMom, ADad: T): T; override;
    function  Evaluate(const AValue: T): Double; override;
    procedure Mutate(var AValue: T); override;
  public
    constructor Create(APopulationSize: Integer; const AFunc: TFunc<T,
                       Double>); overload;
    property MutationKind: TMutationKind read FMutationKind write FMutationKind;
    property CrossoverKind: TCrossoverKind read FCrossoverKind write FCrossoverKind;
    property OnPostInit: TPostInitProc<T> read FOnPostInit write FOnPostInit;
    property OnMutate: TMutate<T> read FOnMutate write FOnMutate;
  end;

function GRandom: Double;

implementation

function GRandom: Double;
var
  x, y, r2: Double;
begin
  repeat
    x := -1 + 2 * Random; // Choose x, y in uniform
    y := -1 + 2 * Random; // square (-1,-1) to (+1,+1).

    r2 := x * x + y * y;  // Look, if it is in the unit
                          // circle.
  until not ((r2 > 1.0) or (r2 = 0));

  Result := y * Sqrt(-2.0 * Log2(r2) / r2); // Box-Muller transform.
end;

{ TEvolution<T> }

procedure TEvolution<T>.Cataclysm;
var
  i:   Integer;
  itm: PItem;
begin
  Assert(FInited);

  for i := 0 to FPopulationSize - 1 do
  begin
    itm := @FItems[i];
    itm.Value   := CreateRandom;
    itm.Fitness := Evaluate(itm.Value);
    Inc(FEvaluations);
  end;
  DetemineBest;
end;

constructor TEvolution<T>.Create(APopulationSize: Integer);
begin
  inherited Create;

  FPopulationSize       := APopulationSize;
  SelectionKind         := skRouletteWheel;
  ReplacementKind       := rkElitism;
  FIncestPrevention     := 10;
  FCrossoverProbability := 0.8;
  FMutationProbability  := 0.2;
  FReInitPropbability   := 0;
end;

procedure TEvolution<T>.CreateChild(out AChild: TItem);
var
  atmpt:    Integer;
  maxat:    Integer;
  mom, dad: PItem;
  reeval:   Boolean;
  ch:       TItem;
  mp:       Double;
begin
  { Select }

  atmpt := 0;
  maxat := Min(FIncestPrevention, FPopulationSize);

  repeat
    FSelection.Select(mom, dad);
    Inc(atmpt);
  until (atmpt >= maxat) or (Distance(mom.Value, dad.Value) > 0);

  { Reproduce }

  if Random < FCrossoverProbability then
  begin
    ch.Value := Crossover(mom.Value, dad.Value);
    reeval   := True;
  end
  else
    ch := mom^;

  if Random < FReInitPropbability then
  begin
    ch.Value := CreateRandom;
    reeval   := True;
  end
  else
  begin
    mp := FMutationProbability;
    while mp > 1 do
    begin
      Mutate(ch.Value);
      mp     := mp - 1;
      reeval := True;
    end;
    if Random < mp then
    begin
      Mutate(ch.Value);
      reeval := True;
    end;
  end;

  if reeval then
  begin
    ch.Fitness := Evaluate(ch.Value);
    Inc(FEvaluations);
  end;

  AChild := ch;
end;

destructor TEvolution<T>.Destroy;
begin
  FSelection.Free;
  FReplacement.Free;
  inherited;
end;

procedure TEvolution<T>.DetemineBest;
var
  i: Integer;
begin
  FBest := @FItems[0];
  for i := 0 to FPopulationSize - 1 do
  begin
    if FItems[i].Fitness > FBest.Fitness then
      FBest := @FItems[i];
  end;
end;

function TEvolution<T>.GetBest: T;
begin
  Assert(FInited);
  Result := FBest.Value;
end;

function TEvolution<T>.GetItems(AIndex: Integer): TItem;
begin
  Assert(FInited);
  Result := FItems[AIndex];
end;

function TEvolution<T>.GetReplacementKind: TReplacementKind;
begin
  Result := FReplacement.Kind;
end;

function TEvolution<T>.GetSelectionKind: TSelectionKind;
begin
  Result := FSelection.Kind;
end;

procedure TEvolution<T>.InitRandomPopulation;
var
  i: Integer;
begin
  Randomize;
  SetLength(FItems, FPopulationSize);

  for i := 0 to FPopulationSize - 1 do
  begin
    FItems[i].Value   := CreateRandom;
    FItems[i].Fitness := Evaluate(FItems[i].Value);
  end;

  FEvaluations := FPopulationSize;
end;

procedure TEvolution<T>.ReevalAll;
var
  i: Integer;
begin
  for i := 0 to FPopulationSize - 1 do
  begin
    FItems[i].Fitness := Evaluate(FItems[i].Value);
    Inc(FEvaluations);
  end;
  DetemineBest;
end;

procedure TEvolution<T>.SetReplacementKind(const Value: TReplacementKind);
begin
  if (FReplacement = nil) or (FReplacement.Kind <> Value) then
  begin
    FReplacement.Free;
    case Value of
      rkClassic:       FReplacement := TClassicRepl.Create(Self, False);
      rkElitism:       FReplacement := TClassicRepl.Create(Self, True);
      rkSteadyState:   FReplacement := TSteadyStateRepl.Create(Self, False);
      rkSteadyElitism: FReplacement := TSteadyStateRepl.Create(Self, True);
      rkTour:          FReplacement := TTourRepl.Create(Self);
    else
      Assert(False);
    end;
  end;
end;

procedure TEvolution<T>.SetSelectionKind(const Value: TSelectionKind);
begin
  if (FSelection = nil) or (FSelection.Kind <> Value) then
  begin
    FSelection.Free;
    case Value of
      skUniform:       FSelection := TUniformSeln.Create(Self);
      skRouletteWheel: FSelection := TRouletteWheelSeln.Create(Self);
      skRank:          FSelection := TRankSeln.Create(Self);
      skTour:          FSelection := TTourSeln.Create(Self);
    else
      Assert(False);
    end;
  end;
end;

function TEvolution<T>.Step: Integer;
begin
  if not FInited then
  begin
    InitRandomPopulation;
    DetemineBest;

    FInited := True;
    Exit(0);
  end;

  FSelection.NextGeneration;
  FReplacement.NextGeneration;

  FReplacement.Step;
  DetemineBest;

  Inc(FGenerations);
  Result := FGenerations;
end;

{ TEvolution<T>.TSelection }

constructor TEvolution<T>.TSelection.Create(AEvolution: TEvolution<T>);
begin
  inherited Create;
  FEvolution := AEvolution;
end;

procedure TEvolution<T>.TSelection.NextGeneration;
begin
  // Do nothing.
end;

{ TEvolution<T>.TUniformSeln }

function TEvolution<T>.TUniformSeln.Kind: TSelectionKind;
begin
  Result := skUniform;
end;

procedure TEvolution<T>.TUniformSeln.Select(out AMom, ADad: PItem);
begin
  with FEvolution do
  begin
    AMom := @FItems[Random(FPopulationSize)];
    ADad := @FItems[Random(FPopulationSize)];
  end;
end;

{ TEvolution<T>.TRouletteWheelSeln }

function TEvolution<T>.TRouletteWheelSeln.Kind: TSelectionKind;
begin
  Result := skRouletteWheel;
end;

procedure TEvolution<T>.TRouletteWheelSeln.NextGeneration;
var
  poplnsz:  Integer;
  i, idx:   Integer;
  min, avg: Double;
  p:        Double;
  itm:      PItem;
begin
  poplnsz := FEvolution.FPopulationSize;
  FItems  := Copy(FEvolution.FItems); // Make unique copy to freeze
                                      // content.
  { Normalize fitness }

  avg := 0; // Fitness average.
  min := FItems[0].Fitness;

  for i := 0 to poplnsz - 1 do
  begin
    avg := avg + FItems[i].Fitness;
    if FItems[i].Fitness < min then
      min := FItems[i].Fitness;
  end;
  avg := avg / poplnsz;

  if Length(FNormd) <> poplnsz then
    SetLength(FNormd, poplnsz);

  for i := 0 to poplnsz - 1 do
    FNormd[i] := FItems[i].Fitness - min;
  avg := avg - min;

  { Create roulette wheel }

  if Length(FRW) <> poplnsz then
    SetLength(FRW, poplnsz);
  i := 0;
  p := 0;

  while i <> Length(FRW) do
  begin
    if p <= 0 then // Peek an item.
    begin
      idx := Random(poplnsz);
      itm := @FItems[idx];

      if avg > 0 then
        p := FNormd[idx] / avg
      else
        p := 1;
    end;

    if (p >= 1) or (Random <= p) then
    begin
      FRW[i] := itm;
      Inc(i);
    end;
    p := p - 1; // Can result in p < 0. Its ok.
  end;
end;

procedure TEvolution<T>.TRouletteWheelSeln.Select(out AMom, ADad: PItem);
begin
  AMom := FRW[Random(Length(FRW))];
  ADad := FRW[Random(Length(FRW))];
end;

{ TEvolution<T>.TRankSeln }

function TEvolution<T>.TRankSeln.Kind: TSelectionKind;
begin
  Result := skRank;
end;

procedure TEvolution<T>.TRankSeln.NextGeneration;
var
  poplnsz:  Integer;
  i, idx:   Integer;
  avg:      Double;
  p:        Double;
  itm:      PItem;
begin
  poplnsz := FEvolution.FPopulationSize;
  FItems  := Copy(FEvolution.FItems); // Make unique copy to freeze
                                      // content.
  { Sort by fitness }

  SortItems(0, poplnsz - 1);

  { Create rank }

  if Length(FRanked) <> poplnsz then
    SetLength(FRanked, poplnsz);

  avg := (1 + poplnsz) / 2;
  i   := 0;
  p   := 0;

  while i <> Length(FRanked) do
  begin
    if p <= 0 then // Peek an item.
    begin
      idx := Random(poplnsz);
      itm := @FItems[idx];

      if avg > 0 then
        p := (idx + 1) / avg
      else
        p := 1;
    end;

    if (p >= 1) or (Random <= p) then
    begin
      FRanked[i] := itm;
      Inc(i);
    end;
    p := p - 1; // Can result in p < 0. Its ok.
  end;
end;

procedure TEvolution<T>.TRankSeln.Select(out AMom, ADad: PItem);
begin
  AMom := FRanked[Random(Length(FRanked))];
  ADad := FRanked[Random(Length(FRanked))];
end;

procedure TEvolution<T>.TRankSeln.SortItems(L, R: Integer);
var
  I, J:  Integer;
  temp:  TItem;
  pivot: Double;
begin
  if (Length(FItems) = 0) or ((R - L) <= 0) then
    Exit;
  repeat
    I := L;
    J := R;
    pivot := FItems[L + (R - L) shr 1].Fitness;
    repeat
      while FItems[I].Fitness < pivot do
        Inc(I);
      while FItems[J].Fitness > pivot do
        Dec(J);
      if I <= J then
      begin
        if I <> J then
        begin
          temp      := FItems[I];
          FItems[I] := FItems[J];
          FItems[J] := temp;
        end;
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then
      SortItems(L, J);
    L := I;
  until I >= R;
end;

{ TEvolution<T>.TTourSeln }

function TEvolution<T>.TTourSeln.Kind: TSelectionKind;
begin
  Result := skTour;
end;

procedure TEvolution<T>.TTourSeln.Select(out AMom, ADad: PItem);
var
  i:      Integer;
  itm:    PItem;
  d, bst: Double;
begin
  with FEvolution do
  begin
    AMom := @FItems[Random(FPopulationSize)];

    for i := 0 to 3 do
    begin
      itm := @FItems[Random(FPopulationSize)];
      if itm.Fitness > AMom.Fitness then
        AMom := itm;
    end;

    ADad := @FItems[Random(FPopulationSize)];

    for i := 0 to 3 do
    begin
      itm := @FItems[Random(FPopulationSize)];
      if itm.Fitness > ADad.Fitness then
        ADad := itm;
    end;

//    bst  := Abs(AMom.Fitness - ADad.Fitness);

//    for i := 0 to 10 do
//    begin
//      itm := @FItems[Random(FPopulationSize)];
//      d   := Abs(AMom.Fitness - itm.Fitness);
//      d := Distance(AMom.Value, itm.Value);
//
//      if (d < bst) and (d > 0) then
//      begin
//        ADad := itm;
//        bst  := d;
//      end;
//    end;
  end;
end;

{ TEvolution<T>.TReplacement }

constructor TEvolution<T>.TReplacement.Create(AEvolution: TEvolution<T>);
begin
  inherited Create;
  FEvolution := AEvolution;
end;

procedure TEvolution<T>.TReplacement.NextGeneration;
begin
  // Do nothing.
end;

{ TEvolution<T>.TClassicRepl }

constructor TEvolution<T>.TClassicRepl.Create(AEvolution: TEvolution<T>;
  AElitism: Boolean);
begin
  inherited Create(AEvolution);
  FElitism := AElitism;
end;

function TEvolution<T>.TClassicRepl.Kind: TReplacementKind;
begin
  if FElitism then
    Result := rkElitism
  else
    Result := rkClassic;
end;

procedure TEvolution<T>.TClassicRepl.Step;
var
  i:       Integer;
  poplnsz: Integer;
begin
  poplnsz := FEvolution.FPopulationSize;
  SetLength(FNewGen, poplnsz); // Make unique.

  if FElitism then
    FNewGen[0] := FEvolution.FBest^;

  for i := Ord(FElitism) to High(FNewGen) do
    FEvolution.CreateChild(FNewGen[i]);
  FEvolution.FItems := FNewGen;
end;

{ TEvolution<T>.TSteadyStateRepl }

constructor TEvolution<T>.TSteadyStateRepl.Create(
  AEvolution: TEvolution<T>; AElitism: Boolean);
begin
  inherited Create(AEvolution);
  FElitism := AElitism;
end;

function TEvolution<T>.TSteadyStateRepl.Kind: TReplacementKind;
begin
  if FElitism then
    Result := rkSteadyElitism
  else
    Result := rkSteadyState;
end;

procedure TEvolution<T>.TSteadyStateRepl.Step;
var
  i:   Integer;
  itm: PItem;
begin
  with FEvolution do
  begin
    for i := 0 to FPopulationSize - 1 do
    begin
      itm := @FItems[Random(FPopulationSize)];
      if (itm <> FBest) or not FElitism then
      begin
        CreateChild(itm^);
        if itm.Fitness > FBest.Fitness then
          FBest := itm;
      end;
    end;
  end;
end;

{ TEvolution<T>.TTourRepl }

function TEvolution<T>.TTourRepl.Kind: TReplacementKind;
begin
  Result := rkTour;
end;

procedure TEvolution<T>.TTourRepl.Step;
var
  i, j:     Integer;
  wst, itm: PItem;
  poplnsz:  Integer;
begin
  with FEvolution do
  begin
    poplnsz := FPopulationSize;

    for i := 0 to poplnsz - 1 do
    begin
      wst := @FItems[Random(poplnsz)];
      for j := 0 to 0 do
      begin
        itm := @FItems[Random(poplnsz)];
        if itm.Fitness < wst.Fitness then
          wst := itm;
      end;
      CreateChild(wst^);
    end;
  end;
end;

{ TBinaryEvolution<T> }

constructor TBinaryEvolution<T>.Create(APopulationSize: Integer;
  const AFunc: TFunc<T, Double>);
begin
  inherited Create(APopulationSize);
  FFunc          := AFunc;
  FMutationKind  := mkUniform;
  FCrossoverKind := ckOnePoint;
end;

function TBinaryEvolution<T>.CreateRandom: T;
var
  sz: Integer;
begin
  sz := SizeOf(T);

  while sz >= 2 do
  begin
    Dec(sz, 2);
    PWord(@PByte(@Result)[sz])^ := Word(Random($10000));
  end;

  if sz > 0 then
    PByte(@Result)^ := Byte(Random($100));

  if Assigned(FOnPostInit) then
    FOnPostInit(Result);
end;

function TBinaryEvolution<T>.Crossover(const AMom, ADad: T): T;
begin
  case FCrossoverKind of
    ckUniform:  Result := UniformCrossover(AMom, ADad);
    ckOnePoint: Result := OnePointCrossover(AMom, ADad);
  else
    Assert(False);
    Result := Default(T); // Initialize.
  end;
end;

function TBinaryEvolution<T>.Distance(const AMom, ADad: T): Double;
var
  val: Byte;
  i:   Integer;
begin
  Result := 0;

  for i := 0 to SizeOf(T) - 1 do
  begin
    val := PByte(@AMom)[i] xor PByte(@ADad)[i];

    while val <> 0 do
    begin
      Result := Result + 1;
      val    := val and (val - 1);
    end;
  end;
end;

function TBinaryEvolution<T>.Evaluate(const AValue: T): Double;
begin
  Result := FFunc(AValue);
end;

function TBinaryEvolution<T>.IsEqual(const A, B: T): Boolean;
var
  i: Integer;
begin
  for i := 0 to SizeOf(T) - 1 do
  begin
    if PByte(@A)[i] <> PByte(@B)[i] then
      Exit(False);
  end;
  Result := True;
end;

procedure TBinaryEvolution<T>.Mutate(var AValue: T);
var
  i:       Integer;
  bit:     Integer;
  handled: Boolean;
begin
  if Assigned(FOnMutate) then
  begin
    handled := False;
    FOnMutate(AValue, handled);
    if handled then
      Exit;
  end;

  case FMutationKind of
    mkUniform:   UniformMutation(AValue);
    mkSingleBit: SingleBitMutation(AValue);
  else
    Assert(False);
  end;
end;

function TBinaryEvolution<T>.OnePointCrossover(const M, D: T): T;
label
  L;
var
  bit:  Integer;
  i:    Integer;
  atpt: Integer;
begin
  atpt := 0;
L:
  bit := Random(SizeOf(T) * 8);
  i   := 0;

  while i < (bit shr 3) do
  begin
    PByte(@Result)[i] := PByte(@M)[i];
    Inc(i);
  end;

  PByte(@Result)[i] := PByte(@D)[i] xor ((PByte(@D)[i] xor
                       PByte(@M)[i]) and ((1 shl (bit and $7)) - 1));
  Inc(i);

  while i < SizeOf(T) do
  begin
    PByte(@Result)[i] := PByte(@D)[i];
    Inc(i);
  end;

  if (IsEqual(Result, M) or IsEqual(Result, D)) and (atpt < 5) then
  begin
    Inc(atpt);
    goto L;
  end;
end;

procedure TBinaryEvolution<T>.SingleBitMutation(var V: T);
var
  bit: Integer;
begin
  bit := Random(SizeOf(T) * 8);
  PByte(@V)[bit shr 3] := PByte(@V)[bit shr 3] xor (1 shl (bit and $7));
end;

function TBinaryEvolution<T>.UniformCrossover(const M, D: T): T;
var
  i:    Integer;
  mask: Byte;
begin
  for i := 0 to SizeOf(T) - 1 do
  begin
    mask := Random(256);
    PByte(@Result)[i] := PByte(@D)[i] xor ((PByte(@D)[i] xor
                         PByte(@M)[i]) and mask);
  end;
end;

procedure TBinaryEvolution<T>.UniformMutation(var V: T);
var
  i: Integer;
begin
  for i := 0 to SizeOf(T) * 8 - 1 do
  begin
    if Random < 1 / (SizeOf(T) * 8) then
      PByte(@V)[i shr 3] := PByte(@V)[i shr 3] xor (1 shl (i and $7));
  end;
end;

end.

